home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / tooltalk / tooltalk-init.el.z / tooltalk-init.el
Encoding:
Text File  |  1998-05-21  |  6.8 KB  |  216 lines
  1. ;;; -*- Mode: Emacs-Lisp -*-
  2. ;;;
  3. ;;; Registration of the default Tooltalk patterns and handlers.
  4. ;;;
  5. ;;; @(#)tooltalk-init.el 1.8 94/02/22
  6.  
  7.  
  8. (defvar tooltalk-eval-pattern
  9.   '(category TT_HANDLE
  10.        scope TT_SESSION
  11.           op "emacs-eval"
  12.     callback tooltalk-eval-handler))
  13.  
  14. (defvar tooltalk-load-file-pattern
  15.   '(category TT_HANDLE
  16.        scope TT_SESSION
  17.           op "emacs-load-file"
  18.     args ((TT_IN "file" "string"))
  19.     callback tooltalk-load-file-handler))
  20.  
  21. (defvar tooltalk-make-client-frame-pattern 
  22.   '(category TT_HANDLE
  23.        scope TT_SESSION
  24.           op "emacs-make-client-screen"
  25.     callback tooltalk-make-client-frame-handler))
  26.  
  27. (defvar tooltalk-status-pattern 
  28.   '(category TT_HANDLE
  29.        scope TT_SESSION
  30.           op "emacs-status"
  31.     callback tooltalk-status-handler))
  32.  
  33.  
  34. (defvar initial-tooltalk-patterns ())
  35.  
  36. (defun dispatch-initial-tooltalk-message (m)
  37.   (let ((op (get-tooltalk-message-attribute m 'op))
  38.     (patterns initial-tooltalk-patterns))
  39.     (if (stringp op)
  40.         (while patterns
  41.           (let ((p (car patterns)))
  42.             (if (eq (intern op) (tooltalk-pattern-prop-get p 'opsym))
  43.                 (let ((callback (tooltalk-pattern-prop-get p 'callback)))
  44.                   (if callback (funcall callback m p))
  45.                   (setq patterns '()))
  46.               (setq patterns (cdr patterns))))))))
  47.  
  48. (defun make-initial-tooltalk-pattern (args)
  49.   (let ((opcdr (cdr (memq 'op args)))
  50.     (cbcdr (cdr (memq 'callback args))))
  51.     (if (and (consp opcdr) (consp cbcdr))
  52.     (let ((plist (list 'opsym (intern (car opcdr)) 'callback (car cbcdr))))
  53.       (make-tooltalk-pattern (append args (list 'plist plist))))
  54.       (make-tooltalk-pattern args))))
  55.  
  56. (defun register-initial-tooltalk-patterns ()
  57.   (mapcar #'register-tooltalk-pattern 
  58.       (setq initial-tooltalk-patterns
  59.         (mapcar #'make-initial-tooltalk-pattern
  60.             (list tooltalk-eval-pattern
  61.                   tooltalk-load-file-pattern
  62.                   tooltalk-make-client-frame-pattern
  63.                   tooltalk-status-pattern))))
  64.   (add-hook 'tooltalk-unprocessed-message-hook 'dispatch-initial-tooltalk-message))
  65.  
  66.  
  67. (defun unregister-initial-tooltalk-patterns ()
  68.   (mapcar 'destroy-tooltalk-pattern initial-tooltalk-patterns)
  69.   (setq initial-tooltalk-patterns ())
  70.   (remove-hook 'tooltalk-unprocessed-message-hook 'dispatch-initial-tooltalk-message))
  71.  
  72.  
  73. (defun tooltalk:prin1-to-string (form)
  74.   "Like prin1-to-string except: if the string contains embedded nulls (unlikely
  75. but possible) then replace each one with \"\\000\"."
  76.   (let ((string (prin1-to-string form)))
  77.     (let ((parts '())
  78.       index)
  79.       (while (setq index (string-match "\0" string))
  80.     (setq parts 
  81.           (apply 'list "\\000" (substring string 0 index) parts))
  82.     (setq string (substring string (1+ index))))
  83.       (if (not parts)
  84.       string
  85.     (setq parts (apply 'list string parts))
  86.     (apply 'concat (nreverse parts))))))
  87.  
  88. ;; Backwards compatibility
  89. (fset 'tooltalk::prin1-to-string-carefully 'tooltalk:prin1-to-string)
  90.  
  91.  
  92. (defun tooltalk:read-from-string (str)
  93.   "Like read-from-string except: an error is signalled if the entire 
  94. string can't be parsed."
  95.   (let ((res (read-from-string str)))
  96.     (if (< (cdr res) (length str))
  97.     (error "Parse of input string ended prematurely."
  98.            str))
  99.     (car res)))
  100.  
  101.  
  102. (defun tooltalk::eval-string (str)
  103.   (let ((result (eval (car (read-from-string str)))))
  104.     (tooltalk:prin1-to-string result)))
  105.  
  106.  
  107. (defun tooltalk-eval-handler (msg pat)
  108.   (let ((str (get-tooltalk-message-attribute msg 'arg_val 0))
  109.     (result-str nil)
  110.     (failp t))
  111.     (unwind-protect
  112.     (cond
  113.      ;; Assume That the emacs debugger will handle errors.
  114.      ;; If the user throws from the debugger to the cleanup
  115.      ;; form below, failp will remain t.
  116.      (debug-on-error   
  117.       (setq result-str (tooltalk::eval-string str)
  118.         failp nil))
  119.  
  120.      ;; If an error occurs as a result of evaluating
  121.      ;; the string or printing the result, then we'll return 
  122.      ;; a string version of error-info.
  123.      (t
  124.       (condition-case error-info
  125.           (setq result-str (tooltalk::eval-string str)
  126.             failp nil)
  127.         (error 
  128.          (let ((error-str (tooltalk:prin1-to-string error-info)))
  129.            (setq result-str error-str
  130.              failp t))))))
  131.  
  132.       ;; If we get to this point and result-str is still nil, the
  133.       ;; user must have thrown out of the debuggger
  134.       (let ((reply-type (if failp 'fail 'reply))
  135.         (reply-value (or result-str "(debugger exit)")))
  136.     (set-tooltalk-message-attribute reply-value msg 'arg_val 0)
  137.     (return-tooltalk-message msg reply-type)))))
  138.  
  139.  
  140. (defun tooltalk-make-client-frame-handler (m p)
  141.   (let ((nargs (get-tooltalk-message-attribute m 'args_count)))
  142.     (if (not (= 3 nargs))
  143.     (progn
  144.       (set-tooltalk-message-attribute "wrong number of arguments" m 'status_string)
  145.       (return-tooltalk-message m 'fail))))
  146.  
  147.   ;; Note: relying on the fact that arg_ival is returned as a string
  148.  
  149.   (let* ((name   (get-tooltalk-message-attribute m 'arg_val 0))
  150.      (window (get-tooltalk-message-attribute m 'arg_ival 1))
  151.      (args (list (cons 'name name) (cons 'window-id window)))
  152.      (frame (make-frame args)))
  153.     (set-tooltalk-message-attribute (frame-name frame) m 'arg_val 2)
  154.     (return-tooltalk-message m 'reply)))
  155.  
  156.  
  157.  
  158. (defun tooltalk-load-file-handler (m p)
  159.   (let ((path (get-tooltalk-message-attribute m 'file)))
  160.     (condition-case error-info 
  161.     (progn
  162.       (load-file path)
  163.       (return-tooltalk-message m 'reply))
  164.       (error 
  165.        (let ((error-string (tooltalk:prin1-to-string error-info)))
  166.     (set-tooltalk-message-attribute error-string m 'status_string)
  167.     (return-tooltalk-message m 'fail))))))
  168.  
  169.  
  170. (defun tooltalk-status-handler (m p)
  171.   (return-tooltalk-message m 'reply))
  172.  
  173.  
  174. ;; Hack the command-line.
  175.  
  176. (defun command-line-do-tooltalk (arg)
  177.   "Connect to the ToolTalk server."
  178. ;  (setq command-line-args-left
  179. ;    (cdr (tooltalk-open-connection (cons (car command-line-args)
  180. ;                         command-line-args-left))))
  181.   (if (tooltalk-open-connection)
  182.       (register-initial-tooltalk-patterns)
  183.     (display-warning 'tooltalk "Warning: unable to connect to a ToolTalk server.")))
  184.  
  185. (setq command-switch-alist
  186.       (append command-switch-alist
  187.           '(("-tooltalk" . command-line-do-tooltalk))))
  188.  
  189. ;; Add some selection converters.
  190.  
  191. (defun xselect-convert-to-ttprocid (selection type value)
  192.   (let* ((msg (create-tooltalk-message))
  193.      (ttprocid (get-tooltalk-message-attribute msg 'sender)))
  194.     (destroy-tooltalk-message msg)
  195.     ttprocid
  196.     ))
  197.  
  198. (defun xselect-convert-to-ttsession (selection type value)
  199.   (let* ((msg (create-tooltalk-message))
  200.      (ttsession (get-tooltalk-message-attribute msg 'session)))
  201.     (destroy-tooltalk-message msg)
  202.     ttsession
  203.     ))
  204.  
  205. (if (boundp 'selection-converter-alist)
  206.     (setq selection-converter-alist
  207.       (append
  208.        selection-converter-alist
  209.        '((SPRO_PROCID . xselect-convert-to-ttprocid)
  210.          (SPRO_SESSION . xselect-convert-to-ttsession)
  211.          )))
  212.   (setq selection-converter-alist
  213.     '((SPRO_PROCID . xselect-convert-to-ttprocid)
  214.       (SPRO_SESSION . xselect-convert-to-ttsession))))
  215.   
  216.